home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / laplac.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  24.9 KB  |  951 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module laplac)
  13.  
  14. (DECLARE-TOP(SPECIAL DVAR VAR-LIST VAR-PARM-LIST VAR PARM $SAVEFACTORS
  15.           CHECKFACTORS $RATFAC $KEEPFLOAT NOUNL NOUNSFLAG)
  16.      (*EXPR SUBFUNMAKE)
  17.      (*LEXPR $DIFF $EXPAND $MULTTHRU $RATSIMP)
  18.      ) 
  19.  
  20. (DEFUN EXPONENTIATE (POW) 
  21.        ;;;COMPUTES %E**Z WHERE Z IS AN ARBITRARY EXPRESSION TAKING SOME OF THE WORK AWAY FROM SIMPEXPT
  22.        (COND ((ZEROP1 POW) 1)
  23.          ((EQUAL POW 1) '$%E)
  24.          (T (POWER '$%E POW)))) 
  25.  
  26. (DEFUN FIXUPREST (REST) 
  27.        ;;;REST IS A PRODUCT WITHOUT THE MTIMES.FIXUPREST PUTS BACK THE MTIMES
  28.        (COND ((NULL REST) 1)
  29.          ((CDR REST) (CONS '(MTIMES SIMP) REST))
  30.          (T (CAR REST)))) 
  31.  
  32.  
  33. ;(DEFUN POSINT MACRO (X) (SUBST (CADR X) 'Y '(AND (INTEGERP Y) (> Y 0))))
  34. ;(DEFUN NEGINT MACRO (X) (SUBST (CADR X) 'Y '(AND (INTEGERP Y) (< Y 0))))
  35.  
  36. (defmacro posint (x) `(and (integerp ,x) (> ,x 0)))
  37. (defmacro negint (x) `(and (integerp ,x) (< ,x 0)))
  38.  
  39.  
  40. (DEFUN ISQUADRATICP (E X)
  41.     ((LAMBDA (B)
  42.     (COND ((ZEROP1 B) (LIST 0 0 E))
  43.           ((FREEOF X B) (LIST 0 B (MAXIMA-SUBSTITUTE 0 X E)))
  44.           ((SETQ B (ISLINEAR B X))
  45.         (LIST (DIV* (CAR B) 2) (CDR B) (MAXIMA-SUBSTITUTE 0 X E)))))
  46.     (SDIFF E X)))
  47.  
  48.  
  49. ;;;INITIALIZES SOME GLOBAL VARIABLES THEN CALLS THE DISPATCHING FUNCTION
  50.  
  51. (DEFMFUN $LAPLACE (FUN VAR PARM) 
  52.        (SETQ FUN (MRATCHECK FUN))
  53.        (COND ((OR NOUNSFLAG (MEMQ '%LAPLACE NOUNL)) (SETQ FUN (REMLAPLACE FUN))))
  54.        (COND ((AND (NULL (ATOM FUN)) (EQ (CAAR FUN) 'MEQUAL))
  55.           (LIST '(MEQUAL SIMP)
  56.             (LAPLACE (CADR FUN))
  57.             (LAPLACE (CADDR FUN))))
  58.          (T (LAPLACE FUN)))) 
  59.  
  60. ;;;LAMBDA BINDS SOME SPECIAL VARIABLES TO NIL AND DISPATCHES
  61.  
  62. (DEFUN REMLAPLACE (E)
  63.  (COND ((ATOM E) E)
  64.        (T (CONS (DELQ 'LAPLACE (APPEND (CAR E) NIL) 1) (MAPCAR 'REMLAPLACE (CDR E))))))
  65.  
  66. (DEFUN LAPLACE (FUN) 
  67.        ((LAMBDA (DVAR VAR-LIST VAR-PARM-LIST) 
  68.         ;;; Handles easy cases and calls appropriate function on others.
  69.         (COND ((EQUAL FUN 0) 0)
  70.               ((EQUAL FUN 1)
  71.                (COND ((ZEROP1 PARM) (SIMPLIFY (LIST '($DELTA) 0)))
  72.                  (T (POWER PARM -1))))
  73.               ((ALIKE1 FUN VAR) (POWER PARM -2))
  74.               ((OR (ATOM FUN) (FREEOF VAR FUN))
  75.                (COND ((ZEROP1 PARM) (MUL2 FUN (SIMPLIFY (LIST '($DELTA) 0))))
  76.                  (T (MUL2 FUN (POWER PARM -1)))))
  77.               (T ((LAMBDA (OP) 
  78.                   (COND ((EQ OP 'MPLUS)
  79.                      (LAPLUS FUN))
  80.                     ((EQ OP 'MTIMES)
  81.                      (LAPTIMES (CDR FUN)))
  82.                     ((EQ OP 'MEXPT)
  83.                      (LAPEXPT FUN NIL))
  84.                     ((EQ OP '%SIN)
  85.                      (LAPSIN FUN NIL NIL))
  86.                     ((EQ OP '%COS)
  87.                      (LAPSIN FUN NIL T))
  88.                     ((EQ OP '%SINH)
  89.                      (LAPSINH FUN NIL NIL))
  90.                     ((EQ OP '%COSH)
  91.                      (LAPSINH FUN NIL T))
  92.                     ((EQ OP '%LOG)
  93.                      (LAPLOG FUN))
  94.                     ((EQ OP '%DERIVATIVE)
  95.                      (LAPDIFF FUN))
  96.                     ((EQ OP '%INTEGRATE)
  97.                      (LAPINT FUN))
  98.                     ((EQ OP '%SUM)
  99.                      (LIST '(%SUM SIMP)
  100.                            (LAPLACE (CADR FUN))
  101.                            (CADDR FUN)
  102.                            (CADDDR FUN)
  103.                            (CAR (CDDDDR FUN))))
  104.                     ((EQ OP '%ERF)
  105.                      (LAPERF FUN))
  106.                 ((AND (EQ OP '%ILT)(EQ (CADDDR FUN) VAR))
  107.             (COND ((EQ PARM (CADDR FUN))(CADR FUN))
  108.                 (T (SUBST PARM (CADDR FUN)(CADR FUN))))
  109. )                    ((EQ OP '$DELTA)
  110.                      (LAPDELTA FUN NIL))
  111.                     ((SETQ OP ($GET OP '$LAPLACE))
  112.                      (MCALL OP FUN VAR PARM))
  113.                     (T (LAPDEFINT FUN))))
  114.               (CAAR FUN)))))
  115.     NIL
  116.     NIL
  117.     NIL)) 
  118.  
  119. (DEFUN LAPLUS (FUN) 
  120.        (SIMPLUS (CONS '(MPLUS)
  121.               (MAPCAR (FUNCTION LAPLACE) (CDR FUN)))
  122.         1.
  123.         T)) 
  124.  
  125. (DEFUN LAPTIMES (FUN) 
  126.        ;;;EXPECTS A LIST (PERHAPS EMPTY) OF FUNCTIONS MULTIPLIED TOGETHER WITHOUT THE MTIMES
  127.        ;;;SEES IF IT CAN APPLY THE FIRST AS A TRANSFORMATION ON THE REST OF THE FUNCTIONS
  128.        (COND ((NULL FUN) (LIST '(MEXPT SIMP) PARM -1.))
  129.          ((NULL (CDR FUN)) (LAPLACE (CAR FUN)))
  130.          ((FREEOF VAR (CAR FUN))
  131.           (SIMPTIMES (LIST '(MTIMES)
  132.                    (CAR FUN)
  133.                    (LAPTIMES (CDR FUN)))
  134.              1.
  135.              T))
  136.          ((EQ (CAR FUN) VAR)
  137.           (SIMPTIMES (LIST '(MTIMES)
  138.                    -1.
  139.                    (SDIFF (LAPTIMES (CDR FUN)) PARM))
  140.              1.
  141.              T))
  142.          (T ((LAMBDA (OP) 
  143.              (COND ((EQ OP 'MEXPT)
  144.                 (LAPEXPT (CAR FUN) (CDR FUN)))
  145.                    ((EQ OP 'MPLUS)
  146.                 (LAPLUS ($MULTTHRU (FIXUPREST (CDR FUN)) (CAR FUN))))
  147.                    ((EQ OP '%SIN)
  148.                 (LAPSIN (CAR FUN) (CDR FUN) NIL))
  149.                    ((EQ OP '%COS)
  150.                 (LAPSIN (CAR FUN) (CDR FUN) T))
  151.                    ((EQ OP '%SINH)
  152.                 (LAPSINH (CAR FUN) (CDR FUN) NIL))
  153.                    ((EQ OP '%COSH)
  154.                 (LAPSINH (CAR FUN) (CDR FUN) T))
  155.                    ((EQ OP '$DELTA)
  156.                 (LAPDELTA (CAR FUN) (CDR FUN)))
  157.  
  158.                    (T (LAPSHIFT (CAR FUN) (CDR FUN)))))
  159.          (CAAAR FUN))))) 
  160.  
  161. (DEFUN LAPEXPT (FUN REST) 
  162.        ;;;HANDLES %E**(A*T+B)*REST(T), %E**(A*T**2+B*T+C),
  163.        ;;; 1/SQRT(A*T+B), OR T**K*REST(T)
  164.        (PROG (AB BASE-OF-FUN POWER RESULT) 
  165.          (SETQ BASE-OF-FUN (CADR FUN) POWER (CADDR FUN))
  166.          (COND
  167.           ((AND
  168.         (FREEOF VAR BASE-OF-FUN)
  169.         (SETQ 
  170.          AB
  171.          (ISQUADRATICP
  172.           (COND ((EQ BASE-OF-FUN '$%E) POWER)
  173.             (T (SIMPTIMES (LIST '(MTIMES)
  174.                         POWER
  175.                         (LIST '(%LOG)
  176.                           BASE-OF-FUN))
  177.                       1.
  178.                       NIL)))
  179.           VAR)))
  180.            (COND ((EQUAL (CAR AB) 0.) (GO %E-CASE-LIN))
  181.              ((NULL REST) (GO %E-CASE-QUAD))
  182.              (T (GO NOLUCK))))
  183.           ((AND (EQ BASE-OF-FUN VAR) (FREEOF VAR POWER))
  184.            (GO VAR-CASE))
  185.           ((AND (ALIKE1 '((RAT) -1. 2.) POWER) (NULL REST)
  186.             (SETQ AB (ISLINEAR BASE-OF-FUN VAR)))
  187.            (SETQ RESULT (DIV* (CDR AB) (CAR AB)))
  188.            (RETURN (SIMPTIMES
  189.         (LIST '(MTIMES)
  190.               (LIST '(MEXPT)
  191.                 (DIV* '$%PI
  192.                   (LIST '(MTIMES)
  193.                     (CAR AB)
  194.                     PARM))
  195.                 '((RAT) 1. 2.))
  196.               (EXPONENTIATE (LIST '(MTIMES) RESULT PARM))
  197.               (LIST '(MPLUS)
  198.                 1.
  199.                 (LIST '(MTIMES)
  200.                   -1.
  201.                    (LIST '(%ERF)
  202.                          (LIST '(MEXPT)
  203.                                (LIST '(MTIMES)
  204.                                  RESULT
  205.                                  PARM)
  206.                                '((RAT)
  207.                              1.
  208.                              2.)))
  209.                        ))) 1 NIL)))
  210.           (T (GO NOLUCK)))
  211.     %E-CASE-LIN
  212.          (SETQ 
  213.           RESULT
  214.           (COND
  215.            (REST ($RATSIMP ($AT (LAPTIMES REST)
  216.                     (LIST '(MEQUAL SIMP)
  217.                       PARM
  218.                       (LIST '(MPLUS SIMP)
  219.                         PARM
  220.                         (AFIXSIGN (CADR AB)
  221.                               NIL))))))
  222.            (T (LIST '(MEXPT)
  223.             (LIST '(MPLUS)
  224.                   PARM
  225.                   (AFIXSIGN (CADR AB) NIL))
  226.             -1.))))
  227.          (RETURN (SIMPTIMES (LIST '(MTIMES)
  228.                       (EXPONENTIATE (CADDR AB))
  229.                       RESULT)
  230.                 1.
  231.                 NIL))
  232.     %E-CASE-QUAD
  233.          (SETQ RESULT (AFIXSIGN (CAR AB) NIL))
  234.          (SETQ 
  235.           RESULT
  236.            (LIST
  237.         '(MTIMES)
  238.         (DIV* (LIST '(MEXPT)
  239.                 (DIV* '$%PI RESULT)
  240.                 '((RAT) 1. 2.))
  241.               2.)
  242.         (EXPONENTIATE (DIV* (LIST '(MEXPT) PARM 2.)
  243.                     (LIST '(MTIMES)
  244.                       4.
  245.                       RESULT)))
  246.         (LIST '(MPLUS)
  247.               1.
  248.               (LIST '(MTIMES)
  249.                 -1.
  250.                  (LIST '(%ERF)
  251.                        (DIV* PARM
  252.                          (LIST '(MTIMES)
  253.                                2.
  254.                                (LIST '(MEXPT)
  255.                                  RESULT
  256.                                  '((RAT)
  257.                                    1.
  258.                                    2.)))))
  259.                 ))))
  260.          (AND (NULL (EQUAL (CADR AB) 0.))
  261.           (SETQ RESULT
  262.             (MAXIMA-SUBSTITUTE (LIST '(MPLUS)
  263.                       PARM
  264.                       (LIST '(MTIMES)
  265.                         -1.
  266.                         (CADR AB)))
  267.                     PARM
  268.                     RESULT)))
  269.          (RETURN (SIMPTIMES  (LIST '(MTIMES)
  270.                (EXPONENTIATE (CADDR AB))
  271.                RESULT) 1 NIL))
  272.     VAR-CASE
  273.          (COND ((OR (NULL REST) (FREEOF VAR (FIXUPREST REST)))
  274.             (GO VAR-EASY-CASE)))
  275.          (COND ((POSINT POWER)
  276.             (RETURN (AFIXSIGN (APPLY '$DIFF
  277.                          (LIST (LAPTIMES REST)
  278.                            PARM
  279.                            POWER))
  280.                       (EVEN POWER))))
  281.            ((NEGINT POWER)
  282.             (RETURN (MYDEFINT (HACKIT POWER REST)
  283.                       (CREATENAME PARM (MINUS POWER))
  284.                       PARM)))
  285.            (T (GO NOLUCK)))
  286.     VAR-EASY-CASE
  287.          (SETQ POWER
  288.            (SIMPLUS (LIST '(MPLUS) 1. POWER) 1. T))
  289.          (OR (EQ (ASKSIGN POWER) '$POSITIVE) (GO NOLUCK))
  290.          (SETQ RESULT (LIST (LIST '(%GAMMA) POWER)
  291.                 (LIST '(MEXPT)
  292.                       PARM
  293.                       (AFIXSIGN POWER NIL))))
  294.          (AND REST (SETQ RESULT (NCONC RESULT REST)))
  295.          (RETURN (SIMPTIMES (CONS '(MTIMES) RESULT)
  296.                 1.
  297.                 NIL))
  298.     NOLUCK
  299.          (RETURN
  300.           (COND
  301.            ((AND (POSINT POWER)
  302.              (MEMQ (CAAR BASE-OF-FUN)
  303.                '(MPLUS %SIN %COS %SINH %COSH)))
  304.         (LAPTIMES (CONS BASE-OF-FUN
  305.                 (CONS (COND ((= POWER 2.) BASE-OF-FUN)
  306.                         (T (LIST '(MEXPT SIMP)
  307.                              BASE-OF-FUN
  308.                              (SUB1 POWER))))
  309.                       REST))))
  310.            (T (LAPSHIFT FUN REST)))))) 
  311.  
  312. (DEFUN MYDEFINT (F X A) 
  313.        ;;;INTEGRAL FROM A TO INFINITY OF F(X)
  314.        ((LAMBDA (TRYINT) (COND (TRYINT (CAR TRYINT))
  315.                    (T (LIST '(%INTEGRATE SIMP)
  316.                     F
  317.                     X
  318.                     A
  319.                     '$INF))))
  320.     (AND (NOT ($UNKNOWN F))
  321.          (ERRSET ($DEFINT F X A '$INF))))) 
  322.  
  323. (DEFUN CREATENAME 
  324.  ;;;CREATES HOPEFULLY UNIQUE NAMES FOR VARIABLE OF INTEGRATION
  325.  (HEAD TAIL) 
  326.  (implode (NCONC (EXPLODEC HEAD) (EXPLODEC TAIL))))
  327.  
  328. (declare-top (FIXNUM EXPONENT)) 
  329.  
  330. (DEFUN HACKIT (EXPONENT REST) 
  331.        ;;;REDUCES LAPLACE(F(T)/T**N,T,S) CASE TO LAPLACE(F(T)/T**(N-1),T,S) CASE
  332.        (COND ((EQUAL EXPONENT -1.)
  333.           ((LAMBDA (PARM) (LAPTIMES REST)) (CREATENAME PARM 1.)))
  334.          (T (MYDEFINT (HACKIT (f1+ EXPONENT) REST)
  335.               (CREATENAME PARM (DIFFERENCE -1. EXPONENT))
  336.               (CREATENAME PARM (MINUS EXPONENT)))))) 
  337.  
  338. (DECLARE-TOP(NOTYPE EXPONENT)) 
  339.  
  340. (DEFUN AFIXSIGN (FUNCT SIGNSWITCH) 
  341.        ;;;MULTIPLIES FUNCT BY -1 IF SIGNSWITCH IS NIL
  342.        (COND (SIGNSWITCH FUNCT)
  343.          (T (SIMPTIMES (LIST '(MTIMES) -1. FUNCT) 1. T)))) 
  344.  
  345.  
  346.  
  347. (DEFUN LAPSHIFT (FUN REST) 
  348.        (COND ((ATOM FUN) (merror "INTERNAL ERROR"))
  349.          ((OR (MEMQ 'LAPLACE (CAR FUN)) (NULL REST))
  350.           (LAPDEFINT (COND (REST (SIMPTIMES (CONS '(MTIMES)
  351.                        (CONS FUN REST)) 1 T))
  352.                    (T FUN))))
  353.          (T (LAPTIMES (APPEND REST
  354.                   (NCONS (CONS (APPEND (CAR FUN)
  355.                                '(LAPLACE))
  356.                            (CDR FUN)))))))) 
  357.  
  358. (DEFUN MOSTPART (F PARM SIGN A B) 
  359.        ;;;COMPUTES %E**(W*B*%I)*F(S-W*A*%I) WHERE W=-1 IF SIGN IS T ELSE W=1
  360.        ((LAMBDA (SUBSTINFUN) 
  361.         (COND ((ZEROP1 B) SUBSTINFUN)
  362.               (T (LIST '(MTIMES)
  363.                    (EXPONENTIATE (AFIXSIGN (LIST '(MTIMES)
  364.                                  B
  365.                                  '$%I)
  366.                                (NULL SIGN)))
  367.                    SUBSTINFUN))))
  368.     ($AT F
  369.          (LIST '(MEQUAL SIMP)
  370.            PARM
  371.            (LIST '(MPLUS SIMP)
  372.              PARM
  373.              (AFIXSIGN (LIST '(MTIMES)
  374.                      A
  375.                      '$%I)
  376.                    SIGN)))))) 
  377.  
  378. (DEFUN COMPOSE 
  379.  ;;;IF WHICHSIGN IS NIL THEN SIN TRANSFORM ELSE COS TRANSFORM
  380.  (FUN PARM WHICHSIGN A B) 
  381.        ((LAMBDA (RESULT) 
  382.         ($RATSIMP (SIMPTIMES (CONS '(MTIMES)
  383.                        (COND (WHICHSIGN RESULT)
  384.                          (T (CONS '$%I
  385.                               RESULT))))
  386.                      1 NIL)))
  387.     (LIST '((RAT) 1. 2.)
  388.           (LIST '(MPLUS)
  389.             (MOSTPART FUN PARM T A B)
  390.             (AFIXSIGN (MOSTPART FUN PARM NIL A B)
  391.                   WHICHSIGN))))) 
  392.  
  393. (DEFUN LAPSIN 
  394.  ;;;FUN IS OF THE FORM SIN(A*T+B)*REST(T) OR COS
  395.  (FUN REST TRIGSWITCH) 
  396.        ((LAMBDA (AB) 
  397.      (COND
  398.       (AB
  399.         (COND
  400.          (REST (COMPOSE (LAPTIMES REST)
  401.                 PARM
  402.                 TRIGSWITCH
  403.                 (CAR AB)
  404.                 (CDR AB)))
  405.          (T (SIMPTIMES
  406.           (LIST
  407.            '(MTIMES)
  408.            (COND
  409.         ((ZEROP1 (CDR AB))
  410.          (COND (TRIGSWITCH PARM) (T (CAR AB))))
  411.         (T (COND (TRIGSWITCH (LIST '(MPLUS)
  412.                        (LIST '(MTIMES)
  413.                          PARM
  414.                          (LIST '(%COS)
  415.                                (CDR AB)))
  416.                        (LIST '(MTIMES)
  417.                          -1.
  418.                          (CAR AB)
  419.                          (LIST '(%SIN)
  420.                                (CDR AB)))))
  421.              (T (LIST '(MPLUS)
  422.                   (LIST '(MTIMES)
  423.                     PARM
  424.                     (LIST '(%SIN)
  425.                           (CDR AB)))
  426.                   (LIST '(MTIMES)
  427.                     (CAR AB)
  428.                     (LIST '(%COS)
  429.                           (CDR AB))))))))
  430.            (LIST '(MEXPT)
  431.              (LIST '(MPLUS)
  432.                (LIST '(MEXPT) PARM 2.)
  433.                (LIST '(MEXPT) (CAR AB) 2.))
  434.              -1.))
  435.         1 NIL))))
  436.       (T (LAPSHIFT FUN REST))))
  437.     (ISLINEAR (CADR FUN) VAR))) 
  438.  
  439. (DEFUN LAPSINH 
  440.  ;;;FUN IS OF THE FORM SINH(A*T+B)*REST(T) OR IS COSH
  441.  (FUN REST SWITCH) 
  442.     (COND ((ISLINEAR (CADR FUN) VAR)
  443.        ($RATSIMP
  444.     (LAPLUS
  445.      (SIMPLUS
  446.       (LIST '(MPLUS)
  447.         (NCONC (LIST '(MTIMES)
  448.                  (LIST '(MEXPT)
  449.                    '$%E
  450.                    (CADR FUN))
  451.                  '((RAT) 1. 2.))
  452.                REST)
  453.         (AFIXSIGN (NCONC (LIST '(MTIMES)
  454.                        (LIST '(MEXPT)
  455.                          '$%E
  456.                          (AFIXSIGN (CADR FUN)
  457.                                NIL))
  458.                        '((RAT) 1. 2.))
  459.                  REST)
  460.               SWITCH))
  461.       1.
  462.       NIL)))) 
  463.     (T (LAPSHIFT FUN REST))))
  464.  
  465. (DEFUN LAPLOG 
  466.  ;;;FUN IS OF THE FORM LOG(A*T)
  467.  (FUN) ((LAMBDA (AB) 
  468.         (COND ((AND AB (ZEROP1 (CDR AB)))
  469.                (SIMPTIMES (LIST '(MTIMES)
  470.                     (LIST '(MPLUS)
  471.                           (subfunmake '$PSI
  472.                               '(0)
  473.                               (NCONS 1.))
  474.                           (LIST '(%LOG)
  475.                             (CAR AB))
  476.                           (LIST '(MTIMES)
  477.                             -1.
  478.                             (LIST '(%LOG)
  479.                               PARM)))
  480.                     (LIST '(MEXPT)
  481.                           PARM
  482.                           -1.))
  483.                   1 NIL))
  484.               (T (LAPDEFINT FUN))))
  485.     (ISLINEAR (CADR FUN) VAR))) 
  486.  
  487. (DEFUN RAISEUP (FBASE EXPONENT) 
  488.        (COND ((EQUAL EXPONENT 1.) FBASE)
  489.          (T (LIST '(MEXPT) FBASE EXPONENT)))) 
  490.  
  491. (DEFUN LAPDELTA (FUN REST) 
  492.        ;;TAKES TRANSFORM OF DELTA(A*T+B)*F(T)
  493.        ((LAMBDA (AB SIGN RECIPA) 
  494.      (COND
  495.       (AB
  496.        (SETQ RECIPA (POWER (CAR AB) -1) AB (DIV (CDR AB) (CAR AB)))
  497.        (SETQ SIGN (ASKSIGN AB) RECIPA (SIMPLIFYA (LIST '(MABS) RECIPA) NIL))
  498.        (SIMPLIFYA (COND ((EQ SIGN '$POSITIVE) 0)
  499.                 ((EQ SIGN '$ZERO)
  500.                  (LIST '(MTIMES)
  501.                    (MAXIMA-SUBSTITUTE 0 VAR (FIXUPREST REST))
  502.                    RECIPA))
  503.                 (T (LIST '(MTIMES)
  504.                      (MAXIMA-SUBSTITUTE (NEG AB)
  505.                          VAR
  506.                          (FIXUPREST REST))
  507.                      (LIST '(MEXPT)
  508.                        '$%E
  509.                        (CONS '(MTIMES)
  510.                          (CONS PARM (NCONS AB))))
  511.                      RECIPA)))
  512.               NIL))
  513.       (T (LAPSHIFT FUN REST))))
  514.     (ISLINEAR (CADR FUN) VAR) NIL NIL)) 
  515.  
  516. (DEFUN LAPERF (FUN  )
  517.        ((LAMBDA (AB) 
  518.      (COND
  519.       ((AND AB (EQUAL (CDR AB) 0.))
  520.        (SIMPTIMES (LIST '(MTIMES)
  521.          (DIV* (EXPONENTIATE (DIV* (LIST '(MEXPT)
  522.                          PARM
  523.                          2.)
  524.                        (LIST '(MTIMES)
  525.                          4.
  526.                          (LIST '(MEXPT)
  527.                                (CAR AB)
  528.                                2.))))
  529.                PARM)
  530.          (LIST '(MPLUS)
  531.                1.
  532.                (LIST '(MTIMES)
  533.                  -1.
  534.                   (LIST '(%ERF)
  535.                         (DIV* PARM
  536.                           (LIST '(MTIMES)
  537.                             2.
  538.                             (CAR AB))))
  539.                       ))) 1 NIL))
  540.       (T (LAPDEFINT FUN))))
  541.     (ISLINEAR (CADR FUN) VAR)))
  542. (DEFUN LAPDEFINT (FUN)
  543.   (PROG (TRYINT MULT)
  544.     (AND ($UNKNOWN FUN)(GO SKIP))
  545.     (SETQ MULT (SIMPTIMES (LIST '(MTIMES) (EXPONENTIATE
  546.                        (LIST '(MTIMES SIMP) -1 VAR PARM)) FUN) 1 NIL))
  547.     (MEVAL `(($ASSUME) ,@(LIST (LIST '(MGREATERP) PARM 0))))
  548.     (SETQ TRYINT (ERRSET ($DEFINT MULT VAR 0 '$INF)))
  549.     (MEVAL `(($FORGET) ,@(LIST (LIST '(MGREATERP) PARM 0))))
  550.     (AND TRYINT (NOT (EQ (CAAAR TRYINT) '%INTEGRATE))  (RETURN (CAR TRYINT)))
  551.    SKIP (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM))))
  552.  
  553.  
  554. (DECLARE-TOP(FIXNUM ORDER)) 
  555.  
  556. (DEFUN LAPDIFF 
  557.  ;;;FUN IS OF THE FORM DIFF(F(T),T,N) WHERE N IS A POSITIVE INTEGER
  558.  (FUN) (PROG (DIFFLIST DEGREE FRONTEND RESULTLIST NEWDLIST ORDER
  559.           ARG2) 
  560.          (SETQ NEWDLIST (SETQ DIFFLIST (COPY (CDDR FUN))))
  561.          (SETQ ARG2 (LIST '(MEQUAL SIMP) VAR 0.))
  562.     A    (COND ((NULL DIFFLIST)
  563.             (RETURN (CONS '(%DERIVATIVE SIMP)
  564.                   (CONS (LIST '(%LAPLACE SIMP)
  565.                           (CADR FUN)
  566.                           VAR
  567.                           PARM)
  568.                     NEWDLIST))))
  569.            ((EQ (CAR DIFFLIST) VAR)
  570.             (SETQ DEGREE (CADR DIFFLIST) 
  571.               DIFFLIST (CDDR DIFFLIST))
  572.             (GO OUT)))
  573.          (SETQ DIFFLIST (CDR (SETQ FRONTEND (CDR DIFFLIST))))
  574.          (GO A)
  575.     OUT  (COND ((NULL (POSINT DEGREE))
  576.             (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM))))
  577.          (COND (FRONTEND (RPLACD FRONTEND DIFFLIST))
  578.            (T (SETQ NEWDLIST DIFFLIST)))
  579.          (COND (NEWDLIST (SETQ FUN (CONS '(%DERIVATIVE SIMP)
  580.                          (CONS (CADR FUN)
  581.                            NEWDLIST))))
  582.            (T (SETQ FUN (CADR FUN))))
  583.          (SETQ ORDER 0.)
  584.     LOOP (SETQ DEGREE (f1- DEGREE))
  585.          (SETQ RESULTLIST
  586.            (CONS (LIST '(MTIMES)
  587.                    (RAISEUP PARM DEGREE)
  588.                    ($AT ($DIFF FUN VAR ORDER) ARG2))
  589.              RESULTLIST))
  590.          (SETQ ORDER (f1+ ORDER))
  591.          (AND (> DEGREE 0.) (GO LOOP))
  592.          (SETQ RESULTLIST (COND ((CDR RESULTLIST)
  593.                      (CONS '(MPLUS)
  594.                        RESULTLIST))
  595.                     (T (CAR RESULTLIST))))
  596.          (RETURN (SIMPLUS (LIST '(MPLUS)
  597.                       (LIST '(MTIMES)
  598.                         (RAISEUP PARM ORDER)
  599.                         (LAPLACE FUN))
  600.                       (LIST '(MTIMES)
  601.                         -1.
  602.                         RESULTLIST))
  603.                 1 NIL)))) 
  604.  
  605. (DECLARE-TOP(NOTYPE ORDER)) 
  606.  
  607. (DEFUN LAPINT 
  608.  ;;;FUN IS OF THE FORM INTEGRATE(F(X)*G(T)*H(T-X),X,0,T)
  609.  (FUN) (PROG (NEWFUN PARM-LIST F) 
  610.          (AND DVAR (GO CONVOLUTION))
  611.          (SETQ DVAR (CADR (SETQ NEWFUN (CDR FUN))))
  612.          (AND (CDDR NEWFUN)
  613.           (ZEROP1 (CADDR NEWFUN))
  614.           (EQ (CADDDR NEWFUN) VAR)
  615.           (GO CONVOLUTIONTEST))
  616.     NOTCON
  617.          (SETQ NEWFUN (CDR FUN))
  618.          (COND ((CDDR NEWFUN)
  619.             (COND ((AND (FREEOF VAR (CADDR NEWFUN))
  620.                 (FREEOF VAR (CADDDR NEWFUN)))
  621.                (RETURN (LIST '(%INTEGRATE SIMP)
  622.                      (LAPLACE (CAR NEWFUN))
  623.                      DVAR
  624.                      (CADDR NEWFUN)
  625.                      (CADDDR NEWFUN))))
  626.               (T (GO GIVEUP))))
  627.            (T (RETURN (LIST '(%INTEGRATE SIMP)
  628.                     (LAPLACE (CAR NEWFUN))
  629.                     DVAR))))
  630.     GIVEUP
  631.          (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM))
  632.     CONVOLUTIONTEST
  633.          (SETQ NEWFUN ($FACTOR (CAR NEWFUN)))
  634.          (COND ((EQ (CAAR NEWFUN) 'MTIMES)
  635.             (SETQ F (CADR NEWFUN) NEWFUN (CDDR NEWFUN)))
  636.            (T (SETQ F NEWFUN NEWFUN NIL)))
  637.     GOTHRULIST
  638.          (COND ((FREEOF DVAR F)
  639.             (SETQ PARM-LIST (CONS F PARM-LIST)))
  640.            ((FREEOF VAR F) (SETQ VAR-LIST (CONS F VAR-LIST)))
  641.            ((FREEOF DVAR
  642.                 ($RATSIMP (MAXIMA-SUBSTITUTE (LIST '(MPLUS)
  643.                             VAR
  644.                             DVAR)
  645.                           VAR
  646.                           F)))
  647.             (SETQ VAR-PARM-LIST (CONS F VAR-PARM-LIST)))
  648.            (T (GO NOTCON)))
  649.          (COND (NEWFUN (SETQ F (CAR NEWFUN) NEWFUN (CDR NEWFUN))
  650.                (GO GOTHRULIST)))
  651.          (AND
  652.           PARM-LIST
  653.           (RETURN
  654.            (LAPLACE
  655.         (CONS
  656.          '(MTIMES)
  657.          (NCONC PARM-LIST
  658.             (NCONS (LIST '(%INTEGRATE)
  659.                      (CONS '(MTIMES)
  660.                        (APPEND VAR-LIST
  661.                            VAR-PARM-LIST))
  662.                      DVAR
  663.                      0.
  664.                      VAR)))))))
  665.     CONVOLUTION
  666.          (RETURN
  667.           (SIMPTIMES
  668.            (LIST
  669.         '(MTIMES)
  670.         (LAPLACE ($EXPAND (MAXIMA-SUBSTITUTE VAR
  671.                           DVAR
  672.                           (FIXUPREST VAR-LIST))))
  673.         (LAPLACE
  674.          ($EXPAND (MAXIMA-SUBSTITUTE 0.
  675.                       DVAR
  676.                       (FIXUPREST VAR-PARM-LIST)))))
  677.            1.
  678.            T)))) 
  679.  
  680. (DECLARE-TOP(SPECIAL VARLIST RATFORM ILS ILT)) 
  681.  
  682. (DEFMFUN $ILT (EXP ILS ILT) 
  683.  ;;;EXP IS F(S)/G(S) WHERE F AND G ARE POLYNOMIALS IN S AND DEGR(F) < DEGR(G)
  684.      (LET (VARLIST ($SAVEFACTORS T) CHECKFACTORS $RATFAC $KEEPFLOAT) 
  685.         ;;; MAKES ILS THE MAIN VARIABLE
  686.         (SETQ VARLIST (LIST ILS))
  687.         (NEWVAR EXP)
  688.         (ORDERPOINTER VARLIST)
  689.         (SETQ VAR (CAADR (RATREP* ILS)))
  690.         (COND ((AND (NULL (ATOM EXP))
  691.                 (EQ (CAAR EXP) 'MEQUAL))
  692.                (LIST '(MEQUAL)
  693.                  ($ILT (CADR EXP) ILS ILT)
  694.                  ($ILT (CADDR EXP) ILS ILT)))
  695.               ((ZEROP1 EXP) 0.)
  696.               ((FREEOF ILS EXP)
  697.                (LIST '(%ILT SIMP) EXP ILS ILT))
  698.               (T (ILT0 EXP))))) 
  699.  
  700. (DEFUN MAXIMA-RATIONALP (LE V) 
  701.        (COND ((NULL LE))
  702.          ((AND (NULL (ATOM (CAR LE))) (NULL (FREEOF V (CAR LE))))
  703.           NIL)
  704.          (T (MAXIMA-RATIONALP (CDR LE) V)))) 
  705.  
  706. (DEFUN ILT0 
  707.  ;;;THIS FUNCTION DOES THE PARTIAL FRACTION DECOMPOSITION
  708.  (EXP) (PROG (WHOLEPART FRPART NUM DENOM Y CONTENT REAL FACTOR
  709.           APART BPART PARNUMER RATARG RATFORM) 
  710.          (AND (MPLUSP EXP)
  711.           (RETURN (SIMPLUS  (CONS '(MPLUS)
  712.                 (MAPCAR (FUNCTION (LAMBDA(F)($ILT F ILS ILT))) (CDR EXP))) 1 T)))
  713.          (AND (NULL (ATOM EXP))
  714.           (EQ (CAAR EXP) '%LAPLACE)
  715.           (EQ (CADDDR EXP) ILS)
  716.           (RETURN (COND ((EQ (CADDR EXP) ILT) (CADR EXP))
  717.                 (T (SUBST ILT
  718.                            (CADDR EXP)
  719.                            (CADR EXP))))))
  720.          (SETQ RATARG (RATREP* EXP))
  721.          (OR (MAXIMA-RATIONALP VARLIST ILS)
  722.          (RETURN (LIST '(%ILT SIMP) EXP ILS ILT)))
  723.          (SETQ RATFORM (CAR RATARG))
  724.          (SETQ DENOM (RATDENOMINATOR (CDR RATARG)))
  725.          (SETQ FRPART (PDIVIDE (RATNUMERATOR (CDR RATARG)) DENOM))
  726.          (SETQ WHOLEPART (CAR FRPART))
  727.          (SETQ FRPART (RATQU (CADR FRPART) DENOM))
  728.          (COND ((NOT (ZEROP1 (CAR WHOLEPART)))
  729.             (RETURN (LIST '(%ILT SIMP) EXP ILS ILT)))
  730.            ((ZEROP1 (CAR FRPART)) (RETURN 0)))
  731.          (SETQ NUM (CAR FRPART) DENOM (CDR FRPART))
  732.          (SETQ Y (OLDCONTENT DENOM))
  733.          (SETQ CONTENT (CAR Y))
  734.          (SETQ REAL (CADR Y))
  735.          (SETQ FACTOR (PFACTOR REAL))
  736.     LOOP (COND ((NULL (CDDR FACTOR))
  737.             (SETQ APART REAL 
  738.               BPART 1 
  739.               Y '((0 . 1) 1 . 1))
  740.             (GO SKIP)))
  741.          (SETQ APART (PEXPT (CAR FACTOR) (CADR FACTOR)))
  742.          (SETQ BPART (CAR (RATQU REAL APART)))
  743.          (SETQ Y (BPROG APART BPART))
  744.     SKIP (SETQ FRPART
  745.            (CDR (RATDIVIDE (RATTI (RATNUMERATOR NUM)
  746.                       (CDR Y)
  747.                       T)
  748.                    (RATTI (RATDENOMINATOR NUM)
  749.                       (RATTI CONTENT APART T)
  750.                       T))))
  751.          (SETQ 
  752.           PARNUMER
  753.           (CONS (ILT1 (RATQU (RATNUMERATOR FRPART)
  754.                  (RATTI (RATDENOMINATOR FRPART)
  755.                     (RATTI (RATDENOMINATOR NUM)
  756.                            CONTENT
  757.                            T)
  758.                     T))
  759.               (CAR FACTOR)
  760.               (CADR FACTOR))
  761.             PARNUMER))
  762.          (SETQ FACTOR (CDDR FACTOR))
  763.          (COND ((NULL FACTOR)
  764.             (RETURN (SIMPLUS (CONS '(MPLUS) PARNUMER)
  765.                      1.
  766.                      T))))
  767.          (SETQ NUM (CDR (RATDIVIDE (RATTI NUM (CAR Y) T)
  768.                        (RATTI CONTENT BPART T))))
  769.          (SETQ REAL BPART)
  770.          (GO LOOP))) 
  771.  
  772. (DECLARE-TOP(FIXNUM K) (SPECIAL Q Z)) 
  773.  
  774. (DEFUN ILT1 (P Q K)
  775.   ((LAMBDA (Z)
  776.   (COND (( ONEP1 K)(ILT3 P ))
  777.     (T (SETQ Z (BPROG Q (PDERIVATIVE Q VAR)))(ILT2 P K)))) NIL))
  778.  
  779.  
  780. (DEFUN ILT2 
  781.  ;;;INVERTS P(S)/Q(S)**K WHERE Q(S)  IS IRREDUCIBLE
  782.  ;;;DOESN'T CALL ILT3 IF Q(S) IS LINEAR
  783.   (P K)
  784.        (PROG (Y A B) 
  785.         (AND (ONEP1 K)(RETURN (ILT3 P)))
  786.         (SETQ K (f1- K))
  787.          (SETQ A (RATTI P (CAR Z) T))
  788.          (SETQ B (RATTI P (CDR Z) T))
  789.          (SETQ Y (PEXPT Q K))
  790.          (COND
  791.           ((OR (NULL (EQUAL (PDEGREE Q VAR) 1.))
  792.            (> (PDEGREE (CAR P) VAR) 0.))
  793.            (RETURN
  794.         (SIMPLUS
  795.          (LIST
  796.           '(MPLUS)
  797.           (ILT2
  798.            (CDR (RATDIVIDE (RATPLUS A
  799.                         (RATQU (RATDERIVATIVE B
  800.                                   VAR)
  801.                            K))
  802.                    Y))
  803.            K)
  804.           ($MULTTHRU (SIMPTIMES (LIST '(MTIMES)
  805.                    ILT
  806.                    (POWER K -1)
  807.                    (ILT2 (CDR (RATDIVIDE B Y)) K))
  808.                  1.
  809.                  T)))
  810.          1.
  811.          T))))
  812.          (SETQ A (DISREP (POLCOEF Q 1.)) 
  813.            B (DISREP (POLCOEF Q 0.)))
  814.          (RETURN
  815.           (SIMPTIMES (LIST '(MTIMES)
  816.                    (DISREP P)
  817.                    (RAISEUP ILT K)
  818.                    (SIMPEXPT (LIST '(MEXPT)
  819.                            '$%E
  820.                            (LIST '(MTIMES)
  821.                              -1.
  822.                              ILT
  823.                              B
  824.                              (LIST '(MEXPT)
  825.                                A
  826.                                -1.)))
  827.                      1.
  828.                      NIL)
  829.                    (LIST '(MEXPT)
  830.                      A
  831.                      (DIFFERENCE -1. K))
  832.                    (LIST '(MEXPT)
  833.                      (FACTORIAL K)
  834.                      -1.))
  835.              1.
  836.              NIL)))) 
  837.  
  838. (DECLARE-TOP(NOTYPE K)) 
  839.  
  840. ;(DEFUN COEF MACRO (POL) (SUBST (CADR POL) (QUOTE DEG)
  841. ;  '(DISREP (RATQU (POLCOEF (CAR P) DEG) (CDR P)))))
  842.  
  843. (defmacro coef (pol)
  844.   `(DISREP (RATQU (POLCOEF (CAR P) ,pol) (CDR P))))
  845.  
  846. (DEFmfUN LAPSUM N (CONS '(MPLUS)(LISTIFY N)))
  847. (DEFmfUN LAPPROD N (CONS '(MTIMES)(LISTIFY N)))
  848. (DEFmfUN EXPO N (CONS '(MEXPT)(LISTIFY N)))
  849. (DEFUN ILT3 
  850.  ;;;INVERTS P(S)/Q(S) WHERE Q(S) IS IRREDUCIBLE
  851.  (P ) (PROG (DISCRIM SIGN A C D E B1 B0 R TERM1 TERM2 DEGR) 
  852.          (SETQ E (DISREP (POLCOEF Q 0.)) 
  853.            D (DISREP (POLCOEF Q 1.)) 
  854.            DEGR (PDEGREE Q VAR))
  855.           (AND (EQUAL DEGR 1.)
  856.            (RETURN
  857.         (SIMPTIMES (LAPPROD
  858.                  (DISREP P)
  859.                  (EXPO D -1.)
  860.                  (EXPO
  861.                        '$%E
  862.                        (LAPPROD
  863.                          -1.
  864.                          ILT
  865.                          E
  866.                          (EXPO
  867.                            D
  868.                            -1.))))
  869.                1.
  870.                NIL)))
  871.         (SETQ C (DISREP (POLCOEF Q 2)))
  872.           (AND (EQUAL DEGR 2.) (GO QUADRATIC))
  873.           (AND (EQUAL DEGR 3.) (ZEROP1 C) (ZEROP1 D)
  874.            (GO CUBIC))
  875.     (RETURN (LIST '(%ILT SIMP) (DIV* (DISREP P)(DISREP Q)) ILS ILT))
  876.     CUBIC (SETQ  A (DISREP (POLCOEF Q 3))
  877.         R (SIMPNRT (DIV* E A) 3))
  878.         (SETQ D (DIV* (DISREP P)(LAPPROD A (LAPSUM
  879.             (EXPO ILS 3)(EXPO '%R 3)))))
  880.         (RETURN (ILT0 (MAXIMA-SUBSTITUTE R '%R ($PARTFRAC D ILS))))
  881.     QUADRATIC (SETQ B0 (COEF 0) B1 (COEF 1))
  882.  
  883.          (SETQ DISCRIM
  884.            (SIMPLUS (LAPSUM
  885.                   (LAPPROD
  886.                     4.
  887.                     E
  888.                     C)
  889.                   (LAPPROD -1. D D))
  890.                 1.
  891.                 NIL))
  892.          (SETQ SIGN (COND ((FREE DISCRIM '$%I) (ASKSIGN DISCRIM)) (T '$POSITIVE)) 
  893.            TERM1 '(%COS) 
  894.            TERM2 '(%SIN))
  895.     (SETQ DEGR (EXPO '$%E (LAPPROD ILT D (POWER C -1) '((RAT SIMP) -1 2))))
  896.          (COND ((EQ SIGN '$ZERO)
  897.             (RETURN (SIMPTIMES (LAPPROD DEGR (LAPSUM (DIV* B1 C)(LAPPROD
  898.         (DIV* (LAPSUM (LAPPROD 2 B0 C)(LAPPROD -1 B1 D))
  899.         (LAPPROD 2 C C)) ILT))) 1 NIL))
  900. )           ((EQ SIGN '$NEGATIVE)
  901.             (SETQ TERM1 '(%COSH) 
  902.               TERM2 '(%SINH) 
  903.               DISCRIM (SIMPTIMES (LAPPROD
  904.                            -1.
  905.                            DISCRIM)
  906.                          1.
  907.                          T))))
  908.          (SETQ DISCRIM (SIMPNRT DISCRIM 2))
  909.          (SETQ 
  910.           SIGN
  911.           (SIMPTIMES
  912.            (LAPPROD
  913.              (LAPSUM
  914.                (LAPPROD
  915.                  2.
  916.                  B0
  917.                  C)
  918.                (LAPPROD
  919.                  -1.
  920.                  B1
  921.                  D))
  922.              (EXPO DISCRIM -1.))
  923.            1.
  924.            NIL))
  925.          (SETQ C (POWER C -1))
  926.          (SETQ DISCRIM (SIMPTIMES (LAPPROD
  927.                         DISCRIM
  928.                         ILT
  929.                         '((RAT SIMP) 1. 2.)
  930.                         C)
  931.                       1.
  932.                       T))
  933.          (RETURN
  934.           (SIMPTIMES
  935.            (LAPPROD
  936.              C
  937.              DEGR
  938.              (LAPSUM
  939.                (LAPPROD
  940.                  B1
  941.                  (LIST TERM1 DISCRIM))
  942.                (LAPPROD
  943.                  SIGN
  944.                  (LIST TERM2 DISCRIM))))
  945.            1.
  946.            NIL)))) 
  947.  
  948. #-NIL
  949. (DECLARE-TOP(UNSPECIAL DVAR ILS ILT NOUNL PARM Q RATFORM VAR VARLIST
  950.             VAR-LIST VAR-PARM-LIST Z))
  951.